home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The Original Shareware 1.1
/
The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso
/
19
/
madtrb11.zip
/
BLIST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-08-05
|
9KB
|
243 lines
PROGRAM BLIST;
{
Source code list program for Turbo Pascal programs.
Source: "BLIST: A Turbo Pascal Source Code Lister", TUG Lines Volume I, Issue 2
Author: Phillip N. Nickell
Application: CP/M-80 (Modified for PC-DOS,MS-DOS)
}
VAR
BUFF1 : STRING[135]; { INPUT LINE BUFFER }
LISTFIL : TEXT; { FIB FOR LST: OR CON: OUTPUT}
INFILE : TEXT; { FIB FOR INPUT FILE }
BCOUNT : INTEGER; { BEGIN/END COUNTER }
KCOUNT : INTEGER; { COMMENT COUNTER }
LINECT : INTEGER; { OUTPUT FILE LINE COUNTER }
COUNT_BE, { COUNT BEG/END PAIRS FLAG }
PERFSKIP: BOOLEAN; { SKIP PAPER PERFS FLAGS }
CONST
FIRST : BOOLEAN = TRUE; { TRUE WHEN PROG IS RUN }
{ to customize code for your printer and desires - adjust the next two items }
MAXLINE = 54; { max # of lines on page when in PERFSKIP mode }
SKIPLINE = 1; { # of lines to skip at top of form when in PERFSKIP mode }
CR = #13;
LF = #10;
FF = #12;
PROCEDURE CLEAN; { CLEARS SCRN & POSITIONS CURSOR }
BEGIN
CLRSCR;
GOTOXY(1,10);
END;
PROCEDURE LINES(X: INTEGER); { PUTS X AMMOUNT OF BLANK LINES TO OUTPUT FILE }
VAR N: INTEGER;
BEGIN
FOR N := 1 TO X DO
WRITELN(LISTFIL);
END;
(* GET-IN-FILE PROC : When program is first run will check for a file name
passed by DOS, and will try to open that file. If no name is passed, will
ask operator for a file name to open. Proc will tell operator if file
doesn't exist and will allow multiple retrys. On 2nd and later executions,
proc will not check for DOS passed file name. In all cases, proc will
assume a file type of .PAS if file type is not specified.
PROGRAM EXIT from this proc when a null string is entered in response to
a file name request.
*)
PROCEDURE GET_IN_FILE; { GETS INPUT FILE NAME }
VAR FNAM : STRING[14]; { IN FILE NAME }
PARM : STRING[14] ABSOLUTE CSEG:$0081; { PASSED FILE NAME IF ANY }
PARMLTH : BYTE ABSOLUTE CSEG:$0080; { CPM PASSED LTH OF PARM }
EXISTING: BOOLEAN;
BEGIN
REPEAT
IF (PARMLTH IN [1..14]) AND FIRST THEN { POSSIBLE FILE NAME WAS PASSED }
FNAM := COPY(PARM,1,PARMLTH-1) { MOVE POSSIBLE FILE NAME TO FNAM }
ELSE
BEGIN { NOTHING WAS PASSED OR NOT FIRST TRY }
CLEAN;
WRITE('ENTER FILE NAME TO LIST or <cr> to EXIT ');
READLN(FNAM);
END;
IF FNAM = '' THEN HALT; (* ******* EXIT ******** *)
IF POS('.',FNAM) = 0 THEN { FILE TYPE GIVEN ? }
FNAM := CONCAT(FNAM,'.PAS'); { FILE DEFAULT TO .PAS TYPE }
FIRST := FALSE; { GET PASSED FILENAME ONLY ONCE }
ASSIGN( INFILE, FNAM ); { SET UP FILE CTL BLK FOR INPUT FILE }
{$I-}
RESET(INFILE); { CHECK FOR EXISTANCE OF FILE }
{$I+}
EXISTING := (IORESULT = 0); { TRUE IF FILE FOUND }
IF NOT EXISTING THEN
BEGIN
CLEAN;
WRITELN('FILE DOESN''T EXIST'); { TELL OPERATOR THE SAD NEWS }
DELAY(700); { AND LET HIM READ IT }
END;
UNTIL EXISTING; {UNTIL FILE EXISTS }
END; { OF GET_IN_FILE PROCEDURE }
(* GET-OUT-FILE procedure asks operator to select output to console device
or list device, and then assigns and resets a file control block to the
appropriate device. 'C' or 'P' is only correct response, and multiple
retrys are allowed.
*)
PROCEDURE GET_OUT_FILE;
VAR C: CHAR;
BEGIN
REPEAT {UNTIL GOOD SELECTION }
CLEAN;
WRITE('OUTPUT LISTING TO (C)ONSOLE OR (P)RINTER ? ');
READ(KBD,C); C := UPCASE(C);
UNTIL C IN ['C','P'];
WRITELN;
IF C = 'C' THEN
ASSIGN (LISTFIL,'CON:')
ELSE
ASSIGN (LISTFIL,'LST:');
RESET(LISTFIL);
END;
(* GET-OPTIONS procedure asks operator if count of begin/end pairs is
desired, and also if skip over paper perforations is desired. Proc
will set or clear the COUNT_BE flag and the PERFSKIP flag.
*)
PROCEDURE GET_OPTIONS;
VAR C: CHAR;
BEGIN
REPEAT
CLEAN;
WRITE('COUNT OF BEGIN/END PAIRS (Y/N) ? ');
READ(KBD,C); C := UPCASE(C);
UNTIL C IN ['Y','N'];
IF C = 'Y' THEN COUNT_BE := TRUE ELSE COUNT_BE := FALSE;
REPEAT
CLEAN;
WRITE('SKIP PRINTER PERFORATIONS (Y/N) ? ');
READ(KBD,C); C := UPCASE(C);
UNTIL C IN ['Y','N'];
IF C = 'Y' THEN PERFSKIP := TRUE ELSE PERFSKIP := FALSE;
END; { GET_OPTIONS }
(* SCAN_LINE procedure scans one line of Turbo Pascal source code looking
for BEGIN/END pairs, CASE/END pairs, LITERAL fields and COMMENT fields.
BCOUNT is begin/end and case/end counter. KCOUNT is comment counter.
Begin/case/ends are only valid outside of comment fields and literal
constant fields (KCOUNT = 0 and NOT LITERAL).
Some of the code in the SCAN_LINE procedure appears at first glance
to be repetitive and/or redundant, but was added to speed up the process
of scanning each line of source code. The program now spits out listings
much faster than my 160cps printer.
*)
PROCEDURE SCAN_LINE;
VAR LITERAL : BOOLEAN; { TRUE IF IN LITERAL FIELD }
TMP : STRING[7]; { TEMP WORK AREA }
I : INTEGER; { LOOP VARIABLE INDEX }
BUFF2 : STRING[135]; { WORKING LINE BUFFER }
BEGIN
LITERAL := FALSE;
BUFF2[0] := BUFF1[0]; { COPY INPUT BUFFER TO WORKING BUFFER }
FOR I := 1 TO LENGTH(BUFF1) DO { AND TRANSLATE TO UPCASE }
BUFF2[I] := UPCASE(BUFF1[I]);
BUFF2 := CONCAT(' ',BUFF2,' '); { ADD ON SOME WORKING SPACE }
FOR I := 1 TO LENGTH(BUFF2)-6 DO
BEGIN
TMP := COPY(BUFF2,I,7);
IF NOT LITERAL THEN
BEGIN
IF TMP[1] IN ['{','}','(','*'] THEN {MAY BE COMMENT AREA DELIM}
BEGIN
IF (TMP[1] = '{') OR (COPY(TMP,1,2) = '(*') THEN
KCOUNT := SUCC(KCOUNT); { COUNT COMMENT OPENS }
IF (TMP[1] = '}') OR (COPY(TMP,1,2) = '*)') THEN
KCOUNT := PRED(KCOUNT); { UN-COUNT COMMENT CLOSES }
END;
END;
IF KCOUNT = 0 THEN { WE AREN'T IN A COMMENT AREA }
BEGIN
IF TMP[1] = CHR(39) THEN
LITERAL := NOT LITERAL; { TOGGLE LITERAL FLAG }
IF NOT LITERAL AND (TMP[2] IN ['B','C','E']) THEN
BEGIN { ITS A POSBLE BEGIN OR END }
IF (TMP = ' BEGIN ') OR (COPY(TMP,1,6) = ' CASE ') THEN
BEGIN
BCOUNT := SUCC(BCOUNT); { COUNT BEGIN }
I := I+ 5; { SKIP REST OF BEGIN }
END;
IF (COPY(TMP,1,4) = ' END') AND (TMP[5] IN ['.',' ',';']) THEN
BEGIN
BCOUNT := PRED(BCOUNT); { UN-COUNT FOR END }
I := I + 4;
END;
END; {IF NOT LITERAL }
END; { IF KCOUNT = 0 }
END; { FOR I := }
END; {SCAN_LINE}
BEGIN { MAIN PROCEDURE }
REPEAT {FOREVER}
GET_IN_FILE; { FILE TO LIST }
GET_OUT_FILE; { WHERE TO LIST IT }
GET_OPTIONS; { HOW TO LIST IT }
LINES(1); { 1 BLANK LINES ON OUTPUT FILE 0}
LINECT := 1; { OUTPUT LINE COUNTER }
IF COUNT_BE THEN { OPTION WAS TO COUNT THE BEGIN/END PAIRS }
BEGIN
KCOUNT := 0;
BCOUNT := 0;
WRITELN(LISTFIL,' C B'); { counter headings }
END;
WHILE NOT EOF(INFILE) DO
BEGIN
READLN(INFILE, BUFF1);
IF COUNT_BE THEN
BEGIN
SCAN_LINE;
WRITELN(LISTFIL,KCOUNT:2,BCOUNT:3,' ',BUFF1);
END
ELSE
WRITELN(LISTFIL,BUFF1);
IF PERFSKIP THEN
BEGIN
LINECT := SUCC(LINECT);
IF LINECT > MAXLINE THEN
BEGIN
WRITE(LISTFIL,FF); { TOP OF FORM }
LINES(SKIPLINE);
LINECT := 1;
WRITELN(LISTFIL,' C B');
END; { LINECT > MAXLINE }
END; { IF PERFSKIP }
END; { WHILE NOT EOF }
WRITE(CR,LF,'HIT ANY KEY TO CONTINUE '); { allow op to see end of listing }
READ(KBD,BCOUNT);
UNTIL FALSE { REPEAT FOREVER - EXIT IS IN GET_IN_FILE PROCEDURE }
END. { MAIN PROC }